home *** CD-ROM | disk | FTP | other *** search
/ Hottest 6 / Hottest 6 (1996)(PDSoft)[!].iso / software / programming / pascal / unit2 / gadgets.pas < prev    next >
Pascal/Delphi Source File  |  1978-11-24  |  6KB  |  261 lines
  1. unit Gadgets;
  2.  
  3. interface
  4.  
  5. { *    This unit provides an indirect interface into GadTools, to make things
  6.     a little easier to deal with
  7. }
  8.  
  9. uses
  10.     Exec, Base, Intuition, GadTools, Utility;
  11.  
  12. const
  13.     MENUNUM        = $001F;    { Mask for Code in MENUPICK message to get
  14.                                 the number of the menu }
  15.     MENUSHIFT    = 0;        { Amount to 'shr' Code }
  16.  
  17.     ITEMNUM        = $07E0;    { Mask to get the item number }
  18.     ITEMSHIFT    = 5;        { Amount to shift }
  19.     
  20.     SUBNUM        = $F800;    { Mask to get the submenu item number }
  21.     SUBSHIFT    = 11;        { Amount to shift }
  22.     
  23.     NOSUB        = $1F;        { Value for "no sub-item" }
  24. var
  25.     okGadgets    : boolean; { TRUE if everything initializes well }
  26.     
  27. procedure AddTitle(title: string);
  28.  
  29. procedure AddChoice(itemname: string;cmd: char;flags: word;
  30.                     mx: longint;main: boolean);
  31.  
  32. function MakeMenu(win: pWindow): boolean;
  33.  
  34. implementation
  35.  
  36. { Remember that you can change these maximums as you need to }
  37.  
  38. const
  39.     MAX_NEWMENU        = 200;    { Maximum number of menu items per menu strip }
  40.     MAX_MENUSTRBUF    = 4000; { Maximum 4K worth of menu choice strings }
  41.     MAX_MENUSTRIPS    = 20;    { Maximum number of menu strips }
  42. type
  43.     tMenuStripItem    = record
  44.         menu    : pMenu;    { Actual menu strip put together }
  45.         window    : pWindow;    { Window attached to }
  46.         visinfo    : pointer;    { Visual info for menu }
  47.         startp    : word;        { Start position of strings in MenuStrBuf }
  48.         endp    : word;        { End position of strings in MenuStrBuf }
  49.     end;
  50.     tNewMenuArray    = array[1..MAX_NEWMENU] of tNewMenu;
  51.     tMenuStrBuf        = array[1..MAX_MENUSTRBUF] of char;
  52.     tMenuStripList    = array[1..MAX_MENUSTRIPS] of tMenuStripItem;
  53.         
  54. var
  55.     NewMenus    : tNewMenuArray;
  56.     topNewMenu    : word;
  57.     MenuStrBuf    : tMenuStrBuf;
  58.     topMenuStr    : word;
  59.     MenuStripList    : tMenuStripList;
  60.     topMenuStrip    : word;
  61.     menustarted    : boolean;    { Has a menu been started? }
  62.     ExitSave    : pointer;
  63. {----------------------------------------------------------}
  64. procedure AddTitle(title: string);
  65.  
  66. { *    Adds a title for a menu }
  67.  
  68. begin
  69.     if (topNewMenu+1>=MAX_NEWMENU) or
  70.         (topMenuStr+length(title)+2>=MAX_MENUSTRBUF) then
  71.         exit;
  72.     if not menustarted then
  73.     begin
  74.         if topMenuStrip>=MAX_MENUSTRIPS then
  75.             exit;
  76.         inc(topMenuStrip);
  77.         with MenuStripList[topMenuStrip] do
  78.         begin
  79.             menu := nil;
  80.             window := nil;
  81.             startp := topMenuStr+1;
  82.             endp := startp
  83.         end;
  84.         menustarted := TRUE
  85.     end;
  86.     inc(topNewMenu);
  87.     with NewMenus[topNewMenu] do
  88.     begin
  89.         nm_Type := NM_TITLE;
  90.         title := title+#0;
  91.         move(title[1],MenuStrBuf[topMenuStr+1],length(title));
  92.         nm_Label := @MenuStrBuf[topMenuStr+1];
  93.         inc(topMenuStr,length(title));
  94.         nm_CommKey := nil;
  95.         nm_Flags := 0;
  96.         nm_MutualExclude := 0;
  97.         nm_UserData := nil
  98.     end;
  99. end;
  100. {----------------------------------------------------------}
  101. procedure AddChoice(itemname: string;cmd: char;flags: word;
  102.                     mx: longint;main: boolean);
  103.  
  104. { *    Adds a choice to a menu.
  105.     ITEMNAME is the text of the menu item, '_' for a bar.
  106.     CMD is the keyboard shortcut command, #0 for none
  107.     FLAGS include CHECKED, CHECKIT and MENUTOGGLE
  108.     MX is the mutual exclude mask (add all 1 shl itemnumbers together)
  109.         Use zero here if the choice is not of a CHECKIT type
  110.     MAIN is TRUE if this is a main item, FALSE if it is a sub-item }
  111.  
  112. var
  113.     command    : string[2];
  114. begin
  115.     if topMenuStr+ord(itemname<>'_')*(length(itemname)+2+2*ord(cmd>#0))
  116.         >=MAX_MENUSTRBUF then
  117.         exit;
  118.     if not menustarted or (topNewMenu+1>=MAX_NEWMENU) then
  119.         exit;
  120.     inc(topNewMenu);
  121.     with NewMenus[topNewMenu] do
  122.     begin
  123.         if main then
  124.             nm_Type := NM_ITEM
  125.         else
  126.             nm_Type := NM_SUB;
  127.         if itemname='_' then
  128.         begin
  129.             nm_Label := STRPTR(NM_BARLABEL);
  130.             nm_CommKey := nil
  131.         end
  132.         else
  133.         begin
  134.             itemname := itemname+#0;
  135.             move(itemname[1],MenuStrBuf[topMenuStr+1],length(itemname));
  136.             nm_Label := @MenuStrBuf[topMenuStr+1];
  137.             inc(topMenuStr,length(itemname));
  138.             if cmd>#0 then
  139.             begin
  140.                 command := cmd+#0;
  141.                 move(command[1],MenuStrBuf[topMenuStr+1],length(command));
  142.                 nm_CommKey := @MenuStrBuf[topMenuStr+1];
  143.                 inc(topMenuStr,length(command));
  144.             end
  145.             else
  146.                 nm_CommKey := nil;
  147.             MenuStripList[topMenuStrip].endp := topMenuStr
  148.         end;
  149.         nm_Flags := flags;
  150.         nm_MutualExclude := mx;
  151.         nm_UserData := nil
  152.     end
  153. end;
  154. {----------------------------------------------------------}
  155. function MakeMenu(win: pWindow): boolean;
  156.  
  157. { * This function makes and attaches the menu to the given
  158.     window, returning TRUE for a successful operation
  159. }
  160. var
  161.     taglist        : tTagItem;
  162.     menumade    : boolean;
  163. begin
  164.     if not menustarted or (topNewMenu=0) then
  165.     begin
  166.         MakeMenu := FALSE;
  167.         exit;
  168.     end;
  169.     menumade := FALSE;
  170.     inc(topNewMenu);
  171.     with NewMenus[topnewmenu] do
  172.     begin
  173.         nm_Type := NM_END;
  174.         nm_Label := nil;
  175.         nm_CommKey := nil;
  176.         nm_Flags := 0;
  177.         nm_MutualExclude := 0;
  178.         nm_userData := nil
  179.     end;
  180.     with taglist do
  181.     begin
  182.         ti_Tag := TAG_END;
  183.         ti_Data := 0
  184.     end;
  185.     with MenuStripList[topMenuStrip] do
  186.     begin
  187.         menu := CreateMenusA(@NewMenus[1],@taglist);
  188.         if menu<>nil then
  189.         begin
  190.             visinfo := GetVisualInfoA(win^.WScreen,@taglist);
  191.             if visinfo<>nil then
  192.             begin
  193.                 if LayoutMenusA(menu,visinfo,@taglist) then
  194.                 begin
  195.                     if SetMenuStrip(win,menu) then
  196.                     begin
  197.                         menumade := TRUE;
  198.                         window := win
  199.                     end
  200.                     else
  201.                     begin
  202.                         FreeMenus(menu);
  203.                         FreeVisualInfo(visinfo)
  204.                     end
  205.                 end
  206.                 else
  207.                     FreeVisualInfo(visinfo)
  208.             end
  209.         end
  210.     end;
  211.     menustarted := FALSE;
  212.     topNewMenu := 0;
  213.     MakeMenu := menumade
  214. end;
  215. {----------------------------------------------------------}
  216. procedure CloseTopMenu;
  217.  
  218. begin
  219.     with MenuStripList[topMenuStrip] do
  220.     begin
  221.         ClearMenuStrip(window);
  222.         FreeMenus(menu);
  223.         FreeVisualInfo(visinfo);
  224.         topMenuStr := startp-1
  225.     end;
  226.     dec(topMenuStrip)
  227. end;
  228. {----------------------------------------------------------}
  229. {$F+}
  230. procedure CloseGadgets;
  231.  
  232. begin
  233.     if menustarted then
  234.     begin
  235.         dec(topMenuStrip);
  236.         menustarted := FALSE
  237.     end;
  238.     while topMenuStrip>0 do
  239.         CloseTopMenu;
  240.     ExitProc := ExitSave; { Restore exit pointer }
  241.     if GadToolsBase<>nil then
  242.         CloseLibrary(GadToolsBase)
  243. end;
  244. {----------------------------------------------------------}
  245. { Initialization section patches exit routine to close library
  246.   upon exit and initializes the library
  247. }
  248.  
  249. begin
  250.     okGadgets := FALSE;
  251.     GadToolsBase := nil;
  252.     topMenuStr := 0;
  253.     topNewMenu := 0;
  254.     topMenuStrip := 0;
  255.     menustarted := FALSE;
  256.     ExitSave := ExitProc;
  257.     ExitProc := @CloseGadgets; { Add CloseGadgets to exit chain }
  258.     GadToolsBase := OpenLibrary('gadtools.library',0);
  259.     if GadToolsBase<>nil then
  260.         okGadgets := TRUE
  261. end.